home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / DELPHI32 / DATETIME / DRAWC13 / DRAWC13.ZIP / DrawCalendar.pas < prev   
Pascal/Delphi Source File  |  1996-06-23  |  21KB  |  691 lines
  1. // Version 1.3
  2. //
  3. // TDrawCalendar is a component based on though not descended from the
  4. // Calendar in the Samples page of the pallette.  I wanted to unpublish the font
  5. // property which meant I could not descend it directly.  Therefore a lot of
  6. // this code is identical to that of the TCalendar component.  I have put all original
  7. // code at the end of the listing where possible, and highlighted changes to the TCalendar code.
  8. //
  9. // TDrawCalendar is my first component so I do not expect it to be perfect.  My programming
  10. // techniques and style may also be questionable as I am not a professional developer
  11. // but a home taught one who enjoys programming in my spare time.
  12. //
  13. // The purpose of this component is to add flexibility to the calendar component
  14. // to allow:
  15. // 1. Drawing bitmaps, Icons and text onto particular dates of the calendar.
  16. // 2. Allow font setting for the Days of the week, Date numbers and added text
  17. //    as three separate properties (HeaderFont, DateFont and TextFont resp.).
  18. //
  19. //
  20.    
  21.  
  22. unit DrawCalendar;
  23.  
  24. interface
  25.  
  26. uses Classes, Controls, Messages, Windows, Forms, Graphics, StdCtrls,
  27.   Grids, SysUtils;
  28.  
  29. type
  30.   TDayOfWeek = 0..6;
  31.  
  32. type
  33.    TCoordResults = (crXIcon, crYIcon, crXText, crYText, crXColor, crYColor);
  34.  
  35.   TDrawCalendar = class(TCustomGrid)
  36.   private
  37.     // From Calendar sample component
  38.     FDate: TDateTime;
  39.     FMonthOffset: Integer;
  40.     FOnChange: TNotifyEvent;
  41.     FReadOnly: Boolean;
  42.     FStartOfWeek: TDayOfWeek;
  43.     FUpdating: Boolean;
  44.     FUseCurrentDate: Boolean;
  45.     // These are needed for DrawCalendar
  46.     FDateBox : Boolean;
  47.     FLongDay : Boolean;
  48.     FOnDrawCell : TDrawCellEvent;
  49.     FHeaderFont : TFont;
  50.     FTextFont : TFont;
  51.     FDateFont : TFont;
  52.     FCol0Color : TColor;
  53.     FCol1Color : TColor;
  54.     FCol2Color : TColor;
  55.     FCol3Color : TColor;
  56.     FCol4Color : TColor;
  57.     FCol5Color : TColor;
  58.     FCol6Color : TColor;
  59.     // From Calendar sample component
  60.     function GetCellText(ACol, ARow: Integer): string;
  61.     function GetDateElement(Index: Integer): Integer;
  62.     procedure SetCalendarDate(Value: TDateTime);
  63.     procedure SetDateElement(Index: Integer; Value: Integer);
  64.     procedure SetStartOfWeek(Value: TDayOfWeek);
  65.     procedure SetUseCurrentDate(Value: Boolean);
  66.     function StoreCalendarDate: Boolean;
  67.     procedure SetHeaderFont(AFont : Tfont);
  68.     procedure SetTextFont(AFont : Tfont);
  69.     procedure SetDateFont(AFont : Tfont);
  70.     procedure SetDateBox(Value : Boolean);
  71.     procedure SetLongDay(Value : Boolean);
  72.     procedure SetCol0Color(AColor : TColor);
  73.     procedure SetCol1Color(AColor : TColor);
  74.     procedure SetCol2Color(AColor : TColor);
  75.     procedure SetCol3Color(AColor : TColor);
  76.     procedure SetCol4Color(AColor : TColor);
  77.     procedure SetCol5Color(AColor : TColor);
  78.     procedure SetCol6Color(AColor : TColor);
  79.   protected
  80.   // These are straight from the calendar sample component
  81.     procedure Change; dynamic;
  82.     procedure ChangeMonth(Delta: Integer);
  83.     procedure Click; override;
  84.     function DaysPerMonth(AYear, AMonth: Integer): Integer; virtual;
  85.     function DaysThisMonth: Integer; virtual;
  86.     procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
  87.     property Font;
  88.     function IsLeapYear(AYear: Integer): Boolean; virtual;
  89.     function SelectCell(ACol, ARow: Longint): Boolean; override;
  90.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  91.  
  92.     // Specific items to DrawCalendar
  93.     Function GetCoords(TheDate : TDateTime; index : TCoordResults) : Integer;
  94.     function StrAsPChar(var S: Openstring): PChar;
  95.  
  96.   public
  97.     constructor Create(AOwner: TComponent); override;
  98.     property CalendarDate: TDateTime  read FDate write SetCalendarDate stored StoreCalendarDate;
  99.     property CellText[ACol, ARow: Integer]: string read GetCellText;
  100.     procedure NextMonth;
  101.     procedure NextYear;
  102.     procedure PrevMonth;
  103.     procedure PrevYear;
  104.     procedure UpdateCalendar; virtual;
  105.     // These are for The DrawCalendar
  106.     function PasteBitmap(TheDate : TDateTime; TheBitmap : TBitmap) : Boolean;
  107.     function PasteIcon(TheDate : TDateTime; TheIcon : TIcon) : Boolean;
  108.     function PasteText(TheDate : TDateTime; MyText : string) : Boolean;
  109.     function IsCurrentMonth(TheDate: TDateTime): Boolean;
  110.     property canvas;
  111.   published
  112.     property Align;
  113.     property BorderStyle;
  114.     property Color;
  115.     property Ctl3D;
  116.     property Day: Integer index 3  read GetDateElement write SetDateElement stored False;
  117.     property Enabled;
  118.     property GridLineWidth;
  119.     property Month: Integer index 2  read GetDateElement write SetDateElement stored False;
  120.     property ParentColor;
  121.     property ParentFont;
  122.     property ParentShowHint;
  123.     property PopupMenu;
  124.     property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
  125.     property ShowHint;
  126.     property StartOfWeek: TDayOfWeek read FStartOfWeek write SetStartOfWeek;
  127.     property TabOrder;
  128.     property TabStop;
  129.     property UseCurrentDate: Boolean read FUseCurrentDate write SetUseCurrentDate default True;
  130.     property Visible;
  131.     property Year: Integer index 1  read GetDateElement write SetDateElement stored False;
  132.     property OnClick;
  133.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  134.     property OnDblClick;
  135.     property OnDragDrop;
  136.     property OnDragOver;
  137.     property OnEndDrag;
  138.     property OnEnter;
  139.     property OnExit;
  140.     property OnKeyDown;
  141.     property OnKeyPress;
  142.     property OnKeyUp;
  143.     property OnMouseDown;
  144.     property OnMouseUp;
  145.     property OnMouseMove;
  146.  
  147.     //Specific to DrawCalendar
  148.     property OnDrawCell: TDrawCellEvent read FOnDrawCell write FOndrawCell;
  149.     property DefaultColWidth;
  150.     property DefaultRowHeight;
  151.     property HeaderFont : TFont read FHeaderFont write SetHeaderFont;
  152.     property TextFont : TFont read FTextFont write SetTextFont;
  153.     property DateFont : TFont read FDateFont write SetDateFont;
  154.     property DateBox : Boolean read FDateBox write SetDateBox default true;
  155.     property ColumnColor0 : TColor read FCol0color write SetCol0Color;
  156.     property ColumnColor1 : TColor read FCol1color write SetCol1Color;
  157.     property ColumnColor2 : TColor read FCol2color write SetCol2Color;
  158.     property ColumnColor3 : TColor read FCol3color write SetCol3Color;
  159.     property ColumnColor4 : TColor read FCol4color write SetCol4Color;
  160.     property ColumnColor5 : TColor read FCol5color write SetCol5Color;
  161.     property ColumnColor6 : TColor read FCol6color write SetCol6Color;
  162.     property UseLongDayNames : Boolean read FLongDay write SetLongDay default False;
  163.   end;
  164.  
  165. procedure Register;
  166.  
  167. implementation
  168.  
  169. constructor TDrawCalendar.Create(AOwner: TComponent);
  170. begin
  171.   inherited Create(AOwner);
  172.   { defaults }
  173.   FDateBox := True;
  174.   FLongDay := False;
  175.   FHeaderFont := TFont.create;
  176.   FTextFont := TFont.create;
  177.   FDateFont := TFont.create;
  178.   FCol0Color := clNone;
  179.   FCol1Color := clNone;
  180.   FCol2Color := clNone;
  181.   FCol3Color := clNone;
  182.   FCol4Color := clNone;
  183.   FCol5Color := clNone;
  184.   FCol6Color := clNone;
  185.   FUseCurrentDate := True;
  186.   HeaderFont.size := 12;
  187.   DateFont.color := clRed;
  188.   DateFont.name := 'Times New Roman';
  189.   TextFont.color := clBlue;
  190.   FixedCols := 0;
  191.   FixedRows := 1;
  192.   ColCount := 7;
  193.   RowCount := 7;
  194.   ScrollBars := ssNone;
  195.   Options := Options - [goRangeSelect] + [goDrawFocusSelected];
  196.   FDate := Date;
  197.   UpdateCalendar;
  198.   // Refers to DrawCalendar
  199.   DefaultColWidth := 84;
  200.   DefaultRowHeight := 50;
  201. end;
  202.  
  203. procedure TDrawCalendar.Change;
  204. begin
  205.   if Assigned(FOnChange) then FOnChange(Self);
  206. end;
  207.  
  208. procedure TDrawCalendar.Click;
  209. var
  210.   TheCellText: string;
  211. begin
  212.   inherited Click;
  213.   TheCellText := CellText[Col, Row];
  214.   if TheCellText <> '' then Day := StrToInt(TheCellText);
  215. end;
  216.  
  217. function TDrawCalendar.IsLeapYear(AYear: Integer): Boolean;
  218. begin
  219.   Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
  220. end;
  221.  
  222. function TDrawCalendar.DaysPerMonth(AYear, AMonth: Integer): Integer;
  223. const
  224.   DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
  225. begin
  226.   Result := DaysInMonth[AMonth];
  227.   if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result); { leap-year Feb is special }
  228. end;
  229.  
  230. function TDrawCalendar.DaysThisMonth: Integer;
  231. begin
  232.   Result := DaysPerMonth(Year, Month);
  233. end;
  234.  
  235. procedure TDrawCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
  236. var
  237.   TheText: string;
  238. begin
  239.   if (ARow <> 0) then
  240.   begin   //Set Column colors for girds containing date numbers
  241.     if (ACol = 0 ) and (ColumnColor0 <> clNone) then
  242.         Canvas.Brush.color := ColumnColor0;
  243.     if (ACol = 1 ) and (ColumnColor1 <> clNone) then
  244.         Canvas.Brush.color := ColumnColor1;
  245.     if (ACol = 2 ) and (ColumnColor2 <> clNone) then
  246.         Canvas.Brush.color := ColumnColor2;
  247.     if (ACol = 3 ) and (ColumnColor3 <> clNone) then
  248.         Canvas.Brush.color := ColumnColor3;
  249.     if (ACol = 4 ) and (ColumnColor4 <> clNone) then
  250.         Canvas.Brush.color := ColumnColor4;
  251.     if (ACol = 5 ) and (ColumnColor5 <> clNone) then
  252.         Canvas.Brush.color := ColumnColor5;
  253.     if (ACol = 6 ) and (ColumnColor6 <> clNone) then
  254.         Canvas.Brush.color := ColumnColor6;
  255.   end;
  256.   TheText := CellText[ACol, ARow];
  257.   with ARect, Canvas do begin
  258.      if ARow = 0 then
  259.         begin
  260.         font := HeaderFont;
  261.         TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
  262.           Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
  263.         font := TextFont;
  264.           end else
  265.    if TheText <> '' then
  266.     begin
  267.        font := DateFont;
  268.        TextRect(ARect, Left + 3, Top, TheText);
  269.        if DateBox then
  270.        begin
  271.         Self.Canvas.MoveTo(Left, Top + TextHeight('N'));
  272.         LineTo(Left + (TextWidth('N')*2), Top + (TextHeight('N')));
  273.         LineTo(Left + (TextWidth('N')*2), Top - 1);
  274.        end;
  275.             font := TextFont;
  276.      end else
  277.      if TheText = '' then
  278.      begin
  279.      if (ARow <> 0) then
  280.        begin  // This code takes care of those cells without a date number.
  281.          if (ACol = 0 ) and (ColumnColor0 <> clNone) then
  282.                     begin
  283.                     Canvas.Brush.color := ColumnColor0;
  284.                     TextRect(ARect, Left + 3, Top, '');
  285.                     end;
  286.          if (ACol = 1 ) and (ColumnColor1 <> clNone) then
  287.                     begin
  288.                     Canvas.Brush.color := ColumnColor1;
  289.                     TextRect(ARect, Left + 3, Top, '');
  290.                     end;
  291.          if (ACol = 2 ) and (ColumnColor2 <> clNone) then
  292.                     Begin
  293.                     Canvas.Brush.color := ColumnColor2;
  294.                     TextRect(ARect, Left + 3, Top, '');
  295.                     end;
  296.          if (ACol = 3 ) and (ColumnColor3 <> clNone) then
  297.                     Begin
  298.                     Canvas.Brush.color := ColumnColor3;
  299.                     TextRect(ARect, Left + 3, Top, '');
  300.                     end;
  301.          if (ACol = 4 ) and (ColumnColor4 <> clNone) then
  302.                     Begin
  303.                     Canvas.Brush.color := ColumnColor4;
  304.                     TextRect(ARect, Left + 3, Top, '');
  305.                     end;
  306.          if (ACol = 5 ) and (ColumnColor5 <> clNone) then
  307.                     Begin
  308.                     Canvas.Brush.color := ColumnColor5;
  309.                     TextRect(ARect, Left + 3, Top, '');
  310.                     end;
  311.          if (ACol = 6 ) and (ColumnColor6 <> clNone) then
  312.                     Begin
  313.                     Canvas.Brush.color := ColumnColor6;
  314.                     TextRect(ARect, Left + 3, Top, '');
  315.                     end;
  316.        end;
  317.      end;
  318.  
  319.    end;
  320.    if Assigned(FOnDrawCell) then FOnDrawCell(Self, ACol, ARow, ARect, AState);
  321. end;
  322.  
  323. function TDrawCalendar.GetCellText(ACol, ARow: Integer): string;
  324. var
  325.   DayNum: Integer;
  326. begin
  327.   if ARow = 0 then  { day names at tops of columns }
  328.    if UseLongDayNames then
  329.     Result := LongDayNames[(StartOfWeek + ACol) mod 7 + 1] else
  330.     Result := ShortDayNames[(StartOfWeek + ACol) mod 7 + 1]
  331.   else
  332.   begin
  333.     DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
  334.     if (DayNum < 1) or (DayNum > DaysThisMonth) then Result := ''
  335.     else Result := IntToStr(DayNum);
  336.   end;
  337.  
  338. end;
  339.  
  340. function TDrawCalendar.SelectCell(ACol, ARow: Longint): Boolean;
  341. begin
  342.   if ((not FUpdating) and FReadOnly) or (CellText[ACol, ARow] = '') then
  343.     Result := False
  344.   else Result := inherited SelectCell(ACol, ARow);
  345. end;
  346.  
  347. procedure TDrawCalendar.SetCalendarDate(Value: TDateTime);
  348. begin
  349.   FDate := Value;
  350.   UpdateCalendar;
  351.   Change;
  352. end;
  353.  
  354. function TDrawCalendar.StoreCalendarDate: Boolean;
  355. begin
  356.   Result := not FUseCurrentDate;
  357. end;
  358.  
  359. function TDrawCalendar.GetDateElement(Index: Integer): Integer;
  360. var
  361.   AYear, AMonth, ADay: Word;
  362. begin
  363.   DecodeDate(FDate, AYear, AMonth, ADay);
  364.   case Index of
  365.     1: Result := AYear;
  366.     2: Result := AMonth;
  367.     3: Result := ADay;
  368.     else Result := -1;
  369.   end;
  370. end;
  371.  
  372. procedure TDrawCalendar.SetDateElement(Index: Integer; Value: Integer);
  373. var
  374.   AYear, AMonth, ADay: Word;
  375. begin
  376.   if Value > 0 then
  377.   begin
  378.     DecodeDate(FDate, AYear, AMonth, ADay);
  379.     case Index of
  380.       1: if AYear <> Value then AYear := Value else Exit;
  381.       2: if (Value <= 12) and (Value <> AMonth) then AMonth := Value else Exit;
  382.       3: if (Value <= DaysThisMonth) and (Value <> ADay) then ADay := Value else Exit;
  383.       else Exit;
  384.     end;
  385.     FDate := EncodeDate(AYear, AMonth, ADay);
  386.     FUseCurrentDate := False;
  387.     UpdateCalendar;
  388.     Change;
  389.   end;
  390. end;
  391.  
  392. procedure TDrawCalendar.SetStartOfWeek(Value: TDayOfWeek);
  393. begin
  394.   if Value <> FStartOfWeek then
  395.   begin
  396.     FStartOfWeek := Value;
  397.     UpdateCalendar;
  398.   end;
  399. end;
  400.  
  401. procedure TDrawCalendar.SetUseCurrentDate(Value: Boolean);
  402. begin
  403.   if Value <> FUseCurrentDate then
  404.   begin
  405.     FUseCurrentDate := Value;
  406.     if Value then
  407.     begin
  408.       FDate := Date; { use the current date, then }
  409.       UpdateCalendar;
  410.     end;
  411.   end;
  412. end;
  413.  
  414. { Given a value of 1 or -1, moves to Next or Prev month accordingly }
  415. procedure TDrawCalendar.ChangeMonth(Delta: Integer);
  416. var
  417.   AYear, AMonth, ADay: Word;
  418.   NewDate: TDateTime;
  419.   CurDay: Integer;
  420. begin
  421.   DecodeDate(FDate, AYear, AMonth, ADay);
  422.   CurDay := ADay;
  423.   if Delta > 0 then ADay := DaysPerMonth(AYear, AMonth)
  424.   else ADay := 1;
  425.   NewDate := EncodeDate(AYear, AMonth, ADay);
  426.   NewDate := NewDate + Delta;
  427.   DecodeDate(NewDate, AYear, AMonth, ADay);
  428.   if DaysPerMonth(AYear, AMonth) > CurDay then ADay := CurDay
  429.   else ADay := DaysPerMonth(AYear, AMonth);
  430.   CalendarDate := EncodeDate(AYear, AMonth, ADay);
  431. end;
  432.  
  433. procedure TDrawCalendar.PrevMonth;
  434. begin
  435.   ChangeMonth(-1);
  436. end;
  437.  
  438. procedure TDrawCalendar.NextMonth;
  439. begin
  440.   ChangeMonth(1);
  441. end;
  442.  
  443. procedure TDrawCalendar.NextYear;
  444. begin
  445.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  446.   Year := Year + 1;
  447. end;
  448.  
  449. procedure TDrawCalendar.PrevYear;
  450. begin
  451.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  452.   Year := Year - 1;
  453. end;
  454.  
  455. procedure TDrawCalendar.UpdateCalendar;
  456. var
  457.   AYear, AMonth, ADay: Word;
  458.   FirstDate: TDateTime;
  459. begin
  460.   FUpdating := True;
  461.   try
  462.     DecodeDate(FDate, AYear, AMonth, ADay);
  463.     FirstDate := EncodeDate(AYear, AMonth, 1);
  464.     FMonthOffset := 2 - ((DayOfWeek(FirstDate) - StartOfWeek + 7) mod 7); { day of week for 1st of month }
  465.     if FMonthOffset = 2 then FMonthOffset := -5;
  466.     MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 1,
  467.       False, False);
  468.     Invalidate;
  469.   finally
  470.     FUpdating := False;
  471.   end;
  472. end;
  473.  
  474. procedure TDrawCalendar.WMSize(var Message: TWMSize);
  475. var
  476.   GridLines: Integer;
  477. begin
  478.   GridLines := 6 * GridLineWidth;
  479.   DefaultColWidth := (Message.Width - GridLines) div 7;
  480.   DefaultRowHeight := (Message.Height - GridLines) div 7;
  481. end;
  482.  
  483. // SPECIFIC TO DRAW CALENDAR
  484.  
  485. procedure TDrawCalendar.SetDateBox(Value : Boolean);
  486. begin
  487.  if FDateBox <> Value then
  488.    begin
  489.       FDateBox := Value;
  490.       Invalidate;
  491.    end;
  492. end;
  493.  
  494. procedure TDrawCalendar.SetLongDay(Value : Boolean);
  495. begin
  496.  if FLongDay <> Value then
  497.    begin
  498.       FLongDay := Value;
  499.       Invalidate;
  500.    end;
  501. end;
  502.  
  503.  
  504. // This function get the x & y coords for drawing the Icon, Bitmap and text
  505. // Onto the DrawCalendar depending upon the date paramenter
  506. function TDrawCalendar.GetCoords(TheDate : TDateTime;
  507.                                 index : TCoordResults) :  Integer;
  508. Var      vDay, vMonth, vYear : Word;
  509.          Column , Row : integer;
  510.          CellTextString : string[10];
  511. begin
  512.   try
  513.   Result := 0;
  514.   DecodeDate(TheDate, vYear, vMonth, vDay);
  515.     for Row := 1 to 6 do // Iterate through cells to find required date.
  516.     for Column := 0 to 6 do
  517.         begin
  518.           CellTextString := GetCellText(Column,Row);
  519.           if (CellTextString <> '')  and (Strlen(StrAsPChar(CelltextString)) <=2) then
  520.             If (STrToInt(CelltextString) = vDay) and (Year = vYear) then
  521.                case index of   //Return coord depending upon whicjh is required.
  522.                       crXIcon :
  523.                          Result := (Column * DefaultColWidth) +
  524.                                      (DefaultColWidth - 2) + Column;
  525.                       crYIcon :
  526.                          Result := (Row * DefaultRowHeight) + Row + 1;
  527.                       crXText :
  528.                          Result := (Column * DefaultColWidth) + 2 + Column;
  529.                       crYText :
  530.                          Result := (Row * DefaultRowHeight) +
  531.                                   (DefaultRowHeight - 8)  + Row;
  532.                       crXColor :
  533.                          Result := (Column * DefaultColWidth) + Column;
  534.                       crYColor :
  535.                          Result := (Row * DefaultRowHeight) + Row;
  536.                       end;
  537.         end;
  538.         except
  539.             Result := 0;
  540.         end;
  541. end;
  542.  
  543. procedure TDrawCalendar.SetHeaderFont(AFont : Tfont);
  544. begin
  545.   FHeaderFont.Assign(AFont);
  546.   Invalidate;
  547. end;
  548.  
  549. procedure TDrawCalendar.SetTextFont(AFont : Tfont);
  550. begin
  551.   FTextFont.Assign(AFont);
  552.   Invalidate;
  553. end;
  554.  
  555. procedure TDrawCalendar.SetDateFont(AFont : Tfont);
  556. begin
  557.   FDateFont.Assign(AFont);
  558.   Invalidate;
  559. end;
  560.  
  561. procedure TDrawCalendar.SetCol0Color(AColor : TColor);
  562. begin
  563.   FCol0Color := AColor;
  564.   Invalidate;
  565. end;
  566.  
  567. procedure TDrawCalendar.SetCol1Color(AColor : TColor);
  568. begin
  569.   FCol1Color := AColor;
  570.   Invalidate;
  571. end;
  572.  
  573. procedure TDrawCalendar.SetCol2Color(AColor : TColor);
  574. begin
  575.   FCol2Color := AColor;
  576.   Invalidate;
  577. end;
  578.  
  579. procedure TDrawCalendar.SetCol3Color(AColor : TColor);
  580. begin
  581.   FCol3Color := AColor;
  582.   Invalidate;
  583. end;
  584.  
  585. procedure TDrawCalendar.SetCol4Color(AColor : TColor);
  586. begin
  587.   FCol4Color := AColor;
  588.   Invalidate;
  589. end;
  590.  
  591. procedure TDrawCalendar.SetCol5Color(AColor : TColor);
  592. begin
  593.   FCol5Color := AColor;
  594.   Invalidate;
  595. end;
  596.  
  597. procedure TDrawCalendar.SetCol6Color(AColor : TColor);
  598. begin
  599.   FCol6Color := AColor;
  600.   Invalidate;
  601. end;
  602.  
  603. Function TDrawCalendar.PasteBitmap(TheDate : TDateTime; TheBitmap : TBitmap) : Boolean;
  604. begin
  605. try
  606.     if IsCurrentMonth(TheDate) then
  607.     begin
  608.       Canvas.Draw(GetCoords(TheDate, crXIcon) - TheBitmap.width,GetCoords(TheDate, crYIcon), TheBitmap);
  609.       Result := True;
  610.     end else Result := False;
  611.   except
  612.     Result := False;
  613.   end;
  614. end;
  615.  
  616. function TDrawCalendar.PasteIcon(TheDate : TDateTime; TheIcon : TIcon) : Boolean;
  617. begin
  618. try
  619.     if IsCurrentMonth(TheDate) then
  620.     begin
  621.       Canvas.Draw(GetCoords(TheDate, crXIcon),GetCoords(TheDate, crYIcon), TheIcon);
  622.       Result := True;
  623.     end else Result := False;
  624.   except
  625.     Result := False;
  626.   end;
  627. end;
  628.  
  629. function TDrawCalendar.PasteText(TheDate : TDateTime; MyText : string) : Boolean;
  630. Var
  631.     TextOffset : Integer;
  632. begin
  633. try
  634.   setbkmode(canvas.handle, TRANSPARENT);
  635.     if IsCurrentMonth(TheDate) then
  636.     begin
  637.      case font.size of
  638.      1..7:  TextOffSet := 3;
  639.      8: TextOffSet := 7;
  640.      9: TextOffset := 8;
  641.      10..11: TextOffset := 9;
  642.      12 : TextOffset := 12;
  643.      13..22: TextOffSet := Font.Size + 2;
  644.      else
  645.         TextOffset := 1;
  646.         end;
  647.  
  648.       font := Textfont;
  649.       Canvas.TextOut(GetCoords(TheDate, crXText), GetCoords(TheDate, crYText) - TextOffset, MyText);
  650.       Result := True;
  651.     end else Result := False;
  652.   except
  653.     Result := False;
  654.   end;
  655. end;
  656.  
  657.  
  658. function TDrawCalendar.IsCurrentMonth(TheDate: TDateTime): Boolean;
  659. Var
  660.   vday, vmonth, vyear : Word;
  661. begin
  662.   try
  663.   DecodeDate(TheDate, vYear, vMonth, vDay);
  664.   If (Month = vMonth) and (Year = vYear) then
  665.     Result := True else
  666.     Result := False;
  667.   except
  668.     Result := False;
  669.     end;
  670. end;
  671.  
  672. function TDrawCalendar.StrAsPChar(var S: Openstring): PChar;
  673. //Function to convert a string to a pChar.
  674. //This function was borrowed from Delphi Developers Guide by
  675. // Pacheco & Teixeira
  676. begin
  677.    if length(S) = High(S) then Dec(S[0]);
  678.    S[Ord(Length(S)) + 1] := #0;
  679.    Result := @S[1];
  680. end;
  681.  
  682.  
  683.  
  684. procedure Register;
  685. begin
  686.   RegisterComponents('S2', [TDrawCalendar]);
  687. end;
  688.  
  689.  
  690. end.
  691.